home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.003 / stk-3 / stk / 3.1 / STk / Scrollbox.stklos < prev    next >
Encoding:
Text File  |  1996-07-29  |  3.6 KB  |  98 lines

  1. ;;;;
  2. ;;;; S c r o l l b o x . s t k       --  Scroll Listbox composite widget
  3. ;;;;
  4. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5. ;;;; 
  6. ;;;; Permission to use, copy, and/or distribute this software and its
  7. ;;;; documentation for any purpose and without fee is hereby granted, provided
  8. ;;;; that both the above copyright notice and this permission notice appear in
  9. ;;;; all copies and derived works.  Fees for distribution or use of this
  10. ;;;; software or derived works may only be charged with express written
  11. ;;;; permission of the copyright holder.  
  12. ;;;; This software is provided ``as is'' without express or implied warranty.
  13. ;;;;
  14. ;;;;           Author: Erick Gallesio [eg@kaolin.unice.fr]
  15. ;;;;    Creation date: 22-Mar-1994 13:05
  16. ;;;; Last file update:  2-Jul-1996 12:09
  17.  
  18. (require "Tk-classes")
  19.  
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. ;;;;
  22. ;;;; <Scroll-listbox> class definition
  23. ;;;;
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25.  
  26. (define-class <Scroll-listbox> (<Tk-composite-widget> <Listbox>)
  27.   ((listbox       :accessor     listbox-of)
  28.    (h-scrollbar      :accessor     h-scrollbar-of)
  29.    (v-scrollbar      :accessor     v-scrollbar-of)
  30.    (h-scroll-side :accessor     h-scroll-side
  31.           :allocation   :virtual
  32.           :init-keyword :h-scroll-side
  33.           :slot-ref     (lambda (o)
  34.                   (let ((hs (slot-ref o 'h-scrollbar)))
  35.                     (and (winfo 'ismapped hs)
  36.                      (get-keyword :side (pack 'info hs)))))
  37.           :slot-set!    (lambda (o v)
  38.                   (let ((hs (slot-ref o 'h-scrollbar)))
  39.                     (if v
  40.                     (pack hs :fill "x" :side v 
  41.                              :before (slot-ref o 'listbox))
  42.                     (pack 'forget hs)))))
  43.    (v-scroll-side :accessor     v-scroll-side
  44.           :allocation   :virtual
  45.           :init-keyword :v-scroll-side
  46.           :slot-ref     (lambda (o)
  47.                   (let ((vs (slot-ref o 'v-scrollbar)))
  48.                     (and (winfo 'ismapped vs)
  49.                      (get-keyword :side (pack 'info vs)))))
  50.           :slot-set!    (lambda (o v)
  51.                   (let ((vs (slot-ref o 'v-scrollbar)))
  52.                     (if v 
  53.                     (pack vs :fill "y" :side v 
  54.                              :before (slot-ref o 'listbox))
  55.                     (pack 'forget vs)))))
  56.    ;; Non allocated slots
  57.    (background   :accessor     background
  58.          :init-keyword :background
  59.          :allocation   :propagated
  60.          :propagate-to (frame listbox h-scrollbar v-scrollbar))
  61.    (border-width :accessor     border-width 
  62.          :allocation   :propagated
  63.          :init-keyword :border-width
  64.          :propagate-to (frame))
  65.    (relief     :accessor     relief
  66.          :init-keyword :relief
  67.          :allocation   :propagated
  68.          :propagate-to (frame))))
  69.  
  70. ;;;;
  71. ;;;;  <Scroll-listbox> methods
  72. ;;;;
  73.  
  74. (define-method initialize-composite-widget ((self <Scroll-listbox>) initargs parent)
  75.   (let* ((hs (make <Scrollbar> :parent parent :orientation "horizontal"))
  76.      (vs (make <Scrollbar> :parent parent :orientation "vertical"))
  77.      (l  (make <Listbox>   :parent parent)))
  78.  
  79.     ;; Set internal true slots 
  80.     (slot-set! self 'Id              (slot-ref l 'Id))
  81.     (slot-set! self 'listbox      l)
  82.     (slot-set! self 'h-scrollbar  hs)
  83.     (slot-set! self 'v-scrollbar  vs)
  84.  
  85.     ;; Pack internal widgets (Warning: Order is important !!!!)
  86.     (pack vs :fill "y" :side "right")
  87.     (pack l  :expand #t :fill "both" :side 'bottom :after vs)
  88.  
  89.     ;; Attach command to scrollbar and listbox
  90.     (slot-set! l 'x-scroll-command (lambda l (apply (slot-ref hs 'Id) 'set l)))
  91.     (slot-set! l 'y-scroll-command (lambda l (apply (slot-ref vs 'Id) 'set l)))
  92.  
  93.     (slot-set! hs 'command (lambda args (apply (slot-ref l 'Id) 'xview args)))
  94.     (slot-set! vs 'command (lambda args (apply (slot-ref l 'Id) 'yview args)))
  95. ))
  96.  
  97. (provide "Scrollbox")
  98.